perm filename M11C.OLD[M11,LCS] blob
sn#409373 filedate 1979-01-06 generic text, type T, neo UTF8
00100 CFORS3 FORTRAN UNIT GENERATOR ROUTINE
00200 C *** MUSIC V ***
00300 SUBROUTINE FORSAM
00400 COMMON /LM/L(10),M(10),NSAMX
00500 C CAN USE UP TO 10 FIELDS IN UNIT GEN.
00600 COMMON I(1) /P/P(1) /GENS/GENS(1) /LFUNC/LFUNC,XNFUN
00700 1 /XIN/AMP,FREQ
00800 COMMON /INS/INS(1) /NT/RNT(1) /ROUT/ROUT(1)
00900 C INS=INSTRUMENT DEFINITIONS, RNT=NOTE CARD INFO, ROUT=OUTPUT BLOCK
01000 EQUIVALENCE(M1,M(1)),(M2,M(2)),(M3,M(3)),(M4,M(4)),(M5,M(5)),(M6,M
01100 1(6)),(M7,M(7)),(M8,M(8)),(L1,L(1)),(L2,L(2)),(L3,L(3)),(L4,L(4)),(
01200 2 L5,L(5)),(L6,L(6)),(L7,L(7)),(L8,L(8)),(AMP,XIN1),(FREQ,XIN2)
01300 3 ,(I5,I(5)),(I6,I(6)),(I3,I(3))
01400 CC XNFUN=LFUNC-1
01500 C COMMON INITIALIZATION OF GENERATORS
01600 CX N1=I6+2
01700 CX N2=INS(N1-1)-1
01800 CX DO 204 J1=N1,N2
01900 CX J2=J1-N1+1
02000 CX IF(INS(J1).GE.0)GO TO 201
02100 CX200 L(J2)=-INS(J1)
02200 CX M(J2)=1
02300 CX GO TO 204
02400 CX201 M(J2)=0
02500 CX IF(INS(J1)-26262.GT.0)GO TO 203
02600 C***** WHAT DOES THE BIG NUMBER DO?????
02700 C*** IT SEEMS TO BE JUST TO MAKE A FLAG. NOW CHANGED TO FIT INTO 16BITS.
02800 CX202 L(J2)=INS(J1)+I3-1
02900 CX GO TO 204
03000 CX203 L(J2)=INS(J1)-26262
03100 CX204 CONTINUE
03200 CX N3=INS(N1-2)
03300 CX IF(M1.LE.0)AMP=RNT(L1)
03400 CX IF(M2.LE.0)FREQ=RNT(L2)
03500 CX J3= N3 -100
03600 CALL INITIT(J3)
03700 AMP=RNT(L1)
03800 FREQ=RNT(L2)
03900 NSAM=I5
04000 NSAMX=NSAM-1
04100 C OUT OSC AD2 RAI ENV STR AD3 AD4 MLT DIV RAH
04200 GO TO (101,102,103,104,105,106,107,108,109,110,111,112,113,114,
04300 1 115,116),J3
04400 CC IF(NGEN.EQ.14)CALL OPT(L,M,NSAM)
04500 C FOLLOWING IS SUGGESTED HEADER FOR SUBROUTINE OPT
04600 C SUBROUTINE OPT(L,M,NSAM)
04700 C DIMENSION L(8),M(8)
04800 C COMMON /GENS/GENS(1)/LFUNC/LFUNC/NT/RNT(1)/ROUT/ROUT(1)
04900 112 CALL OPT(J1,J2,J3)
05000 113 RETURN
05100 114 RETURN
05200
05300 C UNIT GENERATORS
05400 C OUTPUT BOX
05500 CX 101 IF(M1.LE.0)IN1=RNT(L1)
05600 CX DO 270 J3=0,NSAM-1
05700 CX IF(M1.GT.0)IN1=ROUT(J3+L1)
05800 CX 265 J5=L2+J3
05900 CX ROUT(J5)=IN1+ROUT(J5)
06000 CX 270 CONTINUE
06100 CX RETURN
06200 101 CALL OUTP
06300 C CALLS 'FAIL' OUT BOX
06400 RETURN
06500 CC101 DO 270 K=0,NSAMX
06600 J5=L2+K
06700 270 ROUT(J5)=ROUT(J5)+ROUT(K+L1)
06800 RETURN
06900 C OUTPUT=WHAT'S THERE ALREADY + WHAT'S COMING IN FROM THIS INST.
07000 C THIS NEW FORM ASSUMES THE OUT BOX HAS ONLY 'Bn' AS INPUT.
07100
07200 C OSCILLATOR L1,L2 = P or B L3=B L4=F or P L5=P
07300 C AMPL, TIME, OUTPUT, FUNC, 5TH NO LONGER USED.
07400 C M1, M2 =1 = NT. =0 = ROUT (P=FIXED INPUT, B=DYNAMIC INPUT, F=FUNC.)
07500 102 CALL OSC
07600 C CALL 'FAIL' OSC.
07700 RETURN
07800 CXX 102 SUM=RNT(L5)
07900 CALL LOCGEN(M4,L4)
08000 C FINDS POINTER TO FUNC NUM. IF M4.EQ.1 THEN FNUM WAS IN INST DEF.
08100 CC IF(M1.LE.0)AMP=RNT(L1)
08200 CC IF(M2.LE.0)FREQ=RNT(L2)
08300 DO 293 J3=0,NSAMX
08400 J4=INT(SUM)+L4
08500 F=GENS(J4)
08600 C GENS(J4) IS IN FUNC STORAGE AREA.
08700 IF(M2.GT.0)GO TO 286
08800 SUM=SUM+FREQ
08900 GO TO 290
09000 286 J4=L2+J3
09100 SUM=SUM+ROUT(J4)
09200 290 IF(SUM.GE.XNFUN)SUM=SUM-XNFUN
09300 CC290 IF(SUM.GE.XNFUN)GO TO 287
09400 CC IF(SUM.LT.0.0)GO TO 289
09500 288 J5=L3+J3
09600 IF(M1.GT.0)GO TO 292
09700 ROUT(J5)=AMP*F
09800 GO TO 293
09900 C**********
10000 CC287 SUM=SUM-XNFUN
10100 CC GO TO 288
10200 CC289 SUM=SUM+XNFUN
10300 CC GO TO 288
10400 C******* ABOVE FOR FM (NEG. FREQ. TO OSCIL)
10500 292 J6=L1+J3
10600 ROUT(J5)=ROUT(J6)*F
10700 293 CONTINUE
10800 RNT(L5)=SUM
10900 C L5 POINTS TO NOTE ARRAY. SAVE A POINTER.
11000 RETURN
11100
11200 C 115 NEG OSCILLATOR L1,L2 = P or B L3=B L4=F or P L5=P
11300 C 'NOS' AMPL, TIME, OUTPUT, FUNC, 5TH NO LONGER USED.
11400 C M1, M2 =1 = NT. =0 = ROUT (P=FIXED INPUT, B=DYNAMIC INPUT, F=FUNC.)
11500 115 SUM=RNT(L5)
11600 CALL LOCGEN(M4,L4)
11700 C FINDS POINTER TO FUNC NUM. IF M4.EQ.1 THEN FNUM WAS IN INST DEF.
11800 CC IF(M1.LE.0)AMP=RNT(L1)
11900 CC IF(M2.LE.0)FREQ=RNT(L2)
12000 DO 150 J3=0,NSAMX
12100 J4=INT(SUM)+L4
12200 F=GENS(J4)
12300 C GENS(J4) IS IN FUNC STORAGE AREA.
12400 IF(M2.GT.0)GO TO 151
12500 SUM=SUM+FREQ
12600 GO TO 152
12700 151 J4=L2+J3
12800 SUM=SUM+ROUT(J4)
12900 152 IF(SUM.GE.XNFUN)GO TO 153
13000 IF(SUM.LT.0.0)GO TO 154
13100 155 J5=L3+J3
13200 IF(M1.GT.0)GO TO 156
13300 ROUT(J5)=AMP*F
13400 GO TO 150
13500 C**********
13600 153 SUM=SUM-XNFUN
13700 GO TO 155
13800 154 SUM=SUM+XNFUN
13900 GO TO 155
14000 C******* ABOVE FOR FM (NEG. FREQ. TO OSCIL)
14100 156 J6=L1+J3
14200 ROUT(J5)=ROUT(J6)*F
14300 150 CONTINUE
14400 RNT(L5)=SUM
14500 C L5 POINTS TO NOTE ARRAY. SAVE A POINTER.
14600 RETURN
14700
14800 C ADD TWO BOX
14900 C LOOK AT NT ARRAY FOR FIXED VALUES, LOOK AT ROUT FOR CHANGING VALS.
15000 CC103 IF(M1.LE.0)XIN1=RNT(L1)
15100 CC IF(M2.LE.0)XIN2=RNT(L2)
15200 103 DO 258 J3=0,NSAMX
15300 IF(M1.GT.0)XIN1=ROUT(J3+L1)
15400 IF(M2.GT.0)XIN2=ROUT(L2+J3)
15500 ROUT(J3+L3)=XIN1+XIN2
15600 258 CONTINUE
15700 RETURN
15800
15900 C 116 SUBTRACT
16000 CC116 IF(M1.LE.0)XIN1=RNT(L1)
16100 CC IF(M2.LE.0)XIN2=RNT(L2)
16200 116 DO 1016 J3=0,NSAMX
16300 IF(M1.GT.0)XIN1=ROUT(J3+L1)
16400 IF(M2.GT.0)XIN2=ROUT(L2+J3)
16500 ROUT(J3+L3)=XIN1-XIN2
16600 1016 CONTINUE
16700 RETURN
16800
16900 C RANDOM INTERPOLATING GENERATOR RAI Px Py Bn Pq Pr Ps; OR RAI L1 L2 L3 L4 L5 L6;
17000 C M1=0=Pn M1=1=Bn
17100 104 SUM=RNT(L4)
17200 RN1=RNT(L5)
17300 RN3=RNT(L6)
17400 CC IF(M1.LE.0)XIN1=RNT(L1)
17500 CC IF(M2.LE.0)XIN2=RNT(L2)
17600 IF(SUM.NE.0)GO TO 313
17700 CALL RNDM(RN1)
17800 CALL RNDM(RN3)
17900 C INIT THE RANDOM NUMBERS.
18000 313 DO 340 J3=0,NSAMX
18100 IF(M1.GT.0)XIN1=ROUT(J3+L1)
18200 IF(M2.GT.0)XIN2=ROUT(J3+L2)
18300 IF(XNFUN.GT.SUM)GO TO 320
18400 CC IF(SUM-XNFUN.LT.0)GO TO 320
18500 SUM=SUM-XNFUN
18600 CALL RNDM(RN4)
18700 304 RN2=RN4-RN3
18800 RN1=RN3
18900 RN3=RN4
19000 GO TO 321
19100 320 RN2=RN3-RN1
19200 321 ROUT(J3+L3)=XIN1*(RN1+(RN2*SUM)/XNFUN)
19300 SUM=SUM+XIN2
19400 340 CONTINUE
19500 RNT(L4)=SUM
19600 RNT(L5)=RN1
19700 RNT(L6)=RN3
19800 RETURN
19900
20000 C ENVELOPE GENERATOR ENV PorB, ForP, B, P, P, P, P;
20100 C AMPL FUNC OUT ATCK STDY DCAY STOR
20200 105 SUM=RNT(L7)
20300 CALL LOCGEN(M2,L2)
20400 C FINDS POINTER TO FUNC NUM. IF M2.EQ.1 THEN FNUM WAS IN INST DEF.
20500 XIN4=RNT(L4)
20600 XIN5=RNT(L5)
20700 XIN6=RNT(L6)
20800 XIN5=1./(1./XIN5 - 1./XIN4 -1./XIN6 )
20900 C XIN5 HAS INCR. VALUE OF STEADY STATE. (IT WAS TOTAL DUR. BEFORE.)
21000 C THESE 3 PARAMS ARE ATTACK DUR, TOTAL DUR, DECAY DUR.
21100 C STEADY STATE TIME IS COMPUTED
21200 CC IF(M1.LE.0)AMP =RNT(L1)
21300 CX IF(M4.LE.0)XIN4=FLOAT(RNT(L4))*SFI
21400 CX IF(M5.LE.0)XIN5=FLOAT(RNT(L5))*SFI
21500 CX IF(M6.LE.0)XIN6=FLOAT(RNT(L6))*SFI
21600 XIN4=XIN4/4.
21700 XIN5=XIN5/4.
21800 XIN6=XIN6/4.
21900 387 X1=XNFUN/4.
22000 X2=2.*X1
22100 X3=3.*X1
22200 DO 403 J3=0,NSAMX
22300 J4=INT(SUM)+L2
22400 F=GENS(J4)
22500 IF(M1.GT.0)AMP =ROUT(J3+L1)
22600 IF(SUM-XNFUN.GE.0)SUM=SUM-XNFUN
22700 IF(SUM-X1.GT.0)GO TO 393
22800 CX IF(M4.GT.0)XIN4=FLOAT(ROUT(J3+L4))
22900 SUM=SUM+XIN4
23000 GO TO 402
23100 393 IF(SUM-X2.GT.0)GO TO 397
23200 CX IF(M5.GT.0)XIN5=FLOAT(ROUT(J3+L5))
23300 SUM=SUM+XIN5
23400 GO TO 402
23500 CX397 IF(M6.GT.0)XIN6=FLOAT(ROUT(J3+L6))
23600 397 SUM=SUM+XIN6
23700 402 J7=L3+J3
23800 ROUT(J7)=AMP*F
23900 403 CONTINUE
24000 RNT(L7)=SUM
24100 RETURN
24200
24300 C STEREO OUTPUT BOX L1,L2 = B L3=B1
24400 C IT IS ASSUMED ALL INPUTS ARE 'B' TYPE.
24500 106 NSSAM=2*NSAM
24600 C 6/29/70 L.C.SMITH
24700 ICT=0
24800 DO 510 J3=1,NSSAM,2
24900 J4=L1+ICT
25000 XIN1=ROUT(J4)
25100 505 J5=L3+J3-1
25200 ROUT(J5)=XIN1+ROUT(J5)
25300 506 J4=L2+ICT
25400 XIN2=ROUT(J4)
25500 507 J5=L3+J3
25600 ROUT(J5)=XIN2+ROUT(J5)
25700 510 ICT=ICT+1
25800 RETURN
25900 C STEREO OUTPUT BOX
26000 CX106 IF(M1.GT.0)GO TO 501
26100 CCC 106 IF(M1)500,500,501
26200 CX 500 IN1=I(L1)
26300 CX501 IF(M2.GT.0)GO TO 503
26400 CCC 501 IF(M2)502,502,503
26500 CX 502 IN2=I(L2)
26600 CX 503 NSSAM=2*NSAM
26700 C 6/29/70 L.C.SMITH
26800 CX ICT=0
26900 CX DO 510 J3=1,NSSAM,2
27000 CX IF(M1.LE.0)GO TO 505
27100 CCC IF(M1)505,505,504
27200 CC*** 504 J4=L1+J3-1
27300 CX504 J4=L1+ICT
27400 CX IN1=I(J4)
27500 CX 505 J5=L3+J3-1
27600 CX I(J5)=IN1+I(J5)
27700 CX IF(M2.LE.0)GO TO 507
27800 CCC IF(M2)507,507,506
27900 CC*** 506 J4=L2+J3-1
28000 CX506 J4=L2+ICT
28100 CX IN2=I(J4)
28200 CX 507 J5=L3+J3
28300 CX I(J5)=IN2+I(J5)
28400 CX 510 ICT=ICT+1
28500 CX RETURN
28600
28700 C ADD 3 BOX
28800 CC107 IF(M1.LE.0)XIN1=RNT(L1)
28900 CC IF(M2.LE.0)XIN2=RNT(L2)
29000 107 IF(M3.LE.0)XIN3=RNT(L3)
29100 DO 780 J3=0,NSAMX
29200 IF(M1.GT.0)XIN1=ROUT(L1+J3)
29300 IF(M2.GT.0)XIN2=ROUT(L2+J3)
29400 IF(M3.GT.0)XIN3=ROUT(L3+J3)
29500 ROUT(J3+L4)=XIN1+XIN2+XIN3
29600 780 CONTINUE
29700 RETURN
29800
29900 C ADD 4 BOX
30000 CC 108 IF(M1.LE.0)XIN1=RNT(L1)
30100 CC IF(M2.LE.0)XIN2=RNT(L2)
30200 108 IF(M3.LE.0)XIN3=RNT(L3)
30300 IF(M4.LE.0)XIN4=RNT(L4)
30400 DO 880 K=0,NSAMX
30500 IF(M1.GT.0)XIN1=ROUT(L1+K)
30600 859 IF(M2.GT.0)XIN2=ROUT(L2+K)
30700 IF(M3.GT.0)XIN3=ROUT(L3+K)
30800 863 IF(M4.GT.0)XIN4=ROUT(L4+K)
30900 ROUT(L5+K)=XIN1+XIN2+XIN3+XIN4
31000 880 CONTINUE
31100 RETURN
31200
31300 C MULTIPLIER
31400 CC109 IF(M1.LE.0)XIN1=RNT(L1)
31500 CC IF(M2.LE.0)XIN2=RNT(L2)
31600 109 DO 908 J3=0,NSAMX
31700 IF(M1.GT.0)XIN1=ROUT(J3+L1)
31800 IF(M2.GT.0)XIN2=ROUT(J3+L2)
31900 ROUT(J3+L3)=XIN1*XIN2
32000 908 CONTINUE
32100 RETURN
32200
32300 C 110 DIVIDER
32400 CC110 IF(M1.LE.0)XIN1=RNT(L1)
32500 CC IF(M2.LE.0)XIN2=RNT(L2)
32600 110 DO 1010 J3=0,NSAMX
32700 IF(M1.GT.0)XIN1=ROUT(J3+L1)
32800 IF(M2.GT.0)XIN2=ROUT(J3+L2)
32900 1010 ROUT(J3+L3)=XIN1/XIN2
33000 RETURN
33100
33200
33300 C SET NEW FUNCTION IN OSC OR ENV
33400 CC 110 ILOC=N1+6
33500 CC IF(INS(N1+1).EQ.105) ILOC=N1+4
33600 CC JN1=I(3)+INS(N1)-1
33700 CC IIN1=RNT(JN1)
33800 CC IF(IIN1.GT.0) INS(ILOC)=-(IIN1-1)*LFUNC-1
33900 C 'SET' NO LONGER NEEDED!!!! NOW 110 CAN BE USED FOR SOMETHING ELSE.
34000
34100 C RANDOM AND HOLD GENERATOR RAH Px Py Bn Pq Pr; OR RAH L1 L2 L3 L4 L5;
34200 C M1=0=Pn M1=1=Bn
34300 111 SUM=RNT(L4)
34400 CC IF(M1.LE.0)XIN1=RNT(L1)
34500 CC IF(M2.LE.0)XIN2=RNT(L2)
34600 913 RN=RNT(L5)
34700 IF(SUM.EQ.0)CALL RNDM(RN)
34800 C TO INIT RANDOM NUMB. (COULD THIS EVER LOSE?)
34900 DO 940 J3=0,NSAMX
35000 IF(M1.GT.0) XIN1=ROUT(J3+L1)
35100 IF(M2.GT.0) XIN2=ROUT(J3+L2)
35200 IF(XNFUN.GT.SUM)GO TO 920
35300 CC IF(SUM-XNFUN.LT.0)GO TO 920
35400 SUM=SUM-XNFUN
35500 CALL RNDM(RN)
35600 920 ROUT(J3+L3)=XIN1*RN
35700 SUM=SUM+XIN2
35800 940 CONTINUE
35900 RNT(L4)=SUM
36000 RNT(L5)=RN
36100 RETURN
36200 END
36300
36400 SUBROUTINE RNDM(X)
36500 X=2.*RAN(X)-1.
36600 C SENDS BACK NUMBER BETWEEN -1 AND +1
36700 END
36800
36900 SUBROUTINE LOCGEN(M,L)
37000 COMMON /NT/RNT(1) /LOCG/LOCG(1)
37100 IF(M.EQ.0)L=LOCG(INT(RNT(L)))
37200 C GET POINTER TO START OF FUNC. ARRAY
37300 END
37400
37500 SUBROUTINE OPT(L,M,NSAM)
37600 DIMENSION L(1),M(1)
37700 COMMON /GENS/GENS(1)/LFUNC/LFUNC,XNFUN
37800 1/NT/RNT(1)/ROUT/ROUT(1)
37900 C THIS IS A DUMMY ROUTINE OPT Pm Pn Bn; doubles value of Bn
38000 J1=L(3)
38100 C L(3) MEANS LOOK AT 3RD FIELD OF 'OPT'
38200 J2=J1+NSAM-1
38300 DO 1 K=J1,J2
38400 1 ROUT(K)=ROUT(K)*2
38500 RETURN
38600 END